home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / psd.zip / PSD.EL < prev    next >
Lisp/Scheme  |  1992-07-08  |  13KB  |  388 lines
  1. ;;;
  2. ;;; psd.el 1.9
  3. ;;;
  4. ;;; Modified from gdb.el by Pertti KellomΣki, pk@cs.tut.fi
  5. ;;;
  6.  
  7. ;;; Run psd under GNU Emacs
  8. ;;; Copyright (C) 1992 Pertti KellomΣki.
  9.  
  10. ;;; Psd is free software; you can redistribute it and/or modify
  11. ;;; it under the terms of the GNU General Public License as published by
  12. ;;; the Free Software Foundation; either version 1, or (at your option)
  13. ;;; any later version.
  14.  
  15. ;;; Psd is distributed in the hope that it will be useful,
  16. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;;; GNU General Public License for more details.
  19.  
  20. ;;; You should have received a copy of the GNU General Public License
  21. ;;; along with psd; see the file COPYING.  If not, write to
  22. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24. ;;; Author: Pertti KellomΣki, Tampere University of Technology, Finland
  25. ;;;    pk@cs.tut.fi
  26.  
  27. ;;; Description of psd interface:
  28.  
  29. ;;; A facility is provided for the simultaneous display of the source code
  30. ;;; in one window, while using psd to step through a function in the
  31. ;;; other.  A small arrow in the source window, indicates the current
  32. ;;; line.
  33.  
  34. ;;; Starting up:
  35.  
  36. ;;; In order to use this facility, start up an inferior scheme
  37. ;;; interpreter. Then give the command "M-x psd-mode". This will load
  38. ;;; the psd system into your interpreter. The command "M-x
  39. ;;; psd-debug-file", usually bound to "C-c d" will instrument and load a
  40. ;;; Scheme file into the interpreter. The procedures in the file are
  41. ;;; instrumented so that executing them invokes the debugger. See the
  42. ;;; manual for further details. 
  43.  
  44. ;;; psd-display-frame is the basic display function.  It tries to display
  45. ;;; in the other window, the file and line corresponding to the current
  46. ;;; position in the Scheme window.  For example after a psd-step, it would
  47. ;;; display the line corresponding to the position for the last step.
  48.  
  49. ;;; psd-display-frame is invoked automatically when a filename-and-line-number
  50. ;;; appears in the output.
  51.  
  52. (require 'cmuscheme)
  53.  
  54. ;; Where psd resides.
  55. (defvar psd-directory "/usr/local/lib/psd/"
  56.   "Path of the directory that contains psd.")
  57.  
  58. ;; Add psd into the minor modes.
  59. (defvar psd-mode nil "Indicator for psd-mode")
  60.  
  61. (or (assq 'psd-mode minor-mode-alist)
  62.     (setq minor-mode-alist
  63.       (cons '(psd-mode " Psd") minor-mode-alist)))
  64.  
  65. ;; The temporary files that are used for sending stuff to psd.
  66. (defvar *psd-tmp-source-file* (make-temp-name "/tmp/psd1"))
  67. (defvar *psd-tmp-target-file* (make-temp-name "/tmp/psd2"))
  68.  
  69. (defun psd-mode (&optional arg)
  70.   "Toggle psd-mode, with argument turn on psd-mode.
  71.  
  72. Psd-mode is a minor mode for interacting with a psd running in an
  73. inferior Scheme buffer. Psd is a Scheme debugger that debugs the
  74. program by instrumenting it.
  75.  
  76. The command `psd-debug-file', which is bound to \\[psd-debug-file]
  77. prepares a Scheme file for debugging and loads it into the Scheme 
  78. interpreter.
  79.  
  80. The Scheme mode commands `C-c e', `C-c c-e' and `ESC C-x' now run the
  81. command `psd-send-definition' or `psd-send-definition-and-go if given
  82. an argument. `C-c d' prepares a Scheme file for debugging.
  83.  
  84. For instance to debug a procedure, go to its definition
  85. and type `C-u C-c C-e'. This will put you into the inferior Scheme
  86. buffer ready to try out the definition.
  87.  
  88. The command `psd-set-breakpoint' or `C-x SPC' sets a breakpoint in
  89. current line when given in a Scheme buffer.
  90.  
  91. Entering psd-mode also loads psd into the Scheme interpreter.
  92.  
  93. If the debugger does not seem to work properly, try the command ``M-x
  94. psd-reset'', which will clear breakpoints and restore the debugger
  95. into its initial state."
  96.   (interactive "p")
  97.   (make-local-variable 'psd-mode)
  98.   (if (and (<= arg 1)
  99.        psd-mode)
  100.  
  101.       ;; turn off psd-mode
  102.       (progn 
  103.     (setq psd-filter-accumulator nil)
  104.     (setq psd-last-frame nil)
  105.     (set-process-filter (get-buffer-process (current-buffer))
  106.                 nil)
  107.     (set-process-sentinel (get-buffer-process (current-buffer))
  108.                   nil)
  109.     (setq psd-mode nil))
  110.  
  111.     ;; otherwise set up psd-mode
  112.     (setq psd-mode t)
  113.     (make-local-variable 'psd-filter-accumulator)
  114.     (setq psd-filter-accumulator nil)
  115.     (make-local-variable 'psd-last-frame)
  116.     (setq psd-last-frame nil)
  117.     (local-set-key "\C-cd" 'psd-debug-file)
  118.     (define-key scheme-mode-map "\M-\C-x" 'scheme-or-psd-send-definition);gnu convention
  119.     (define-key scheme-mode-map "\C-ce"    'scheme-or-psd-send-definition)
  120.     (define-key scheme-mode-map "\C-c\C-e" 'scheme-or-psd-send-definition-and-go)
  121.     (define-key scheme-mode-map "\C-cd" 'psd-debug-file)
  122.     (define-key scheme-mode-map "\C-x " 'psd-set-breakpoint)
  123.     (set-process-filter (get-buffer-process (current-buffer))
  124.             'psd-filter)
  125.     (set-process-sentinel (get-buffer-process (current-buffer))
  126.               'psd-sentinel)
  127.     (send-string "scheme"
  128.          (concat "(load \""
  129.              (let ((implementation-file
  130.                 (concat psd-directory "psd-"
  131.                     scheme-program-name
  132.                     ".scm")))
  133.                (if (file-exists-p implementation-file)
  134.                    implementation-file
  135.                  (concat psd-directory "psd.scm")))
  136.              "\"\)\n"))))
  137.  
  138.  
  139. ;; This function is responsible for inserting output from Scheme
  140. ;; into the buffer.
  141. ;; Aside from inserting the text, it notices and deletes
  142. ;; each filename-and-line-number;
  143. ;; that psd prints to identify the selected frame.
  144. ;; It records the filename and line number, and maybe displays that file.
  145.  
  146. (defun psd-filter (proc string)
  147.   (let ((inhibit-quit t))
  148.     (if psd-filter-accumulator
  149.     (psd-filter-accumulate-marker proc
  150.                       (concat psd-filter-accumulator string))
  151.       (psd-filter-scan-input proc string))))
  152.  
  153. (defun psd-filter-accumulate-marker (proc string)
  154.   (setq psd-filter-accumulator nil)
  155.   (if (> (length string) 1)
  156.       (if (= (aref string 1) ?\032)
  157.       (let ((end (string-match "\n" string)))
  158.         (if end
  159.         (progn
  160.           (let* ((first-colon (string-match ":" string 2))
  161.              (second-colon
  162.               (string-match ":" string (1+ first-colon))))
  163.             (setq psd-last-frame
  164.               (cons (substring string 2 first-colon)
  165.                 (string-to-int
  166.                  (substring string (1+ first-colon)
  167.                         second-colon)))))
  168.           (setq psd-last-frame-displayed-p nil)
  169.           (psd-filter-scan-input proc
  170.                      (substring string (1+ end))))
  171.           (setq psd-filter-accumulator string)))
  172.     (psd-filter-insert proc "\032")
  173.     (psd-filter-scan-input proc (substring string 1)))
  174.     (setq psd-filter-accumulator string)))
  175.  
  176. (defun psd-filter-scan-input (proc string)
  177.   (if (equal string "")
  178.       (setq psd-filter-accumulator nil)
  179.     (let ((start (string-match "\032" string)))
  180.       (if start
  181.       (progn (psd-filter-insert proc (substring string 0 start))
  182.          (psd-filter-accumulate-marker proc
  183.                            (substring string start)))
  184.     (psd-filter-insert proc string)))))
  185.  
  186. (defun psd-filter-insert (proc string)
  187.   (let ((moving (= (point) (process-mark proc)))
  188.     (output-after-point (< (point) (process-mark proc)))
  189.     (old-buffer (current-buffer))
  190.     start)
  191.     (set-buffer (process-buffer proc))
  192.     (unwind-protect
  193.     (save-excursion
  194.       ;; Insert the text, moving the process-marker.
  195.       (goto-char (process-mark proc))
  196.       (setq start (point))
  197.       (insert string)
  198.       (set-marker (process-mark proc) (point))
  199.                     ;(psd-maybe-delete-prompt)
  200.       ;; Check for a filename-and-line number.
  201.       (psd-display-frame
  202.        ;; Don't display the specified file
  203.        ;; unless (1) point is at or after the position where output appears
  204.        ;; and (2) this buffer is on the screen.
  205.        (or output-after-point
  206.            (not (get-buffer-window (current-buffer))))
  207.        ;; Display a file only when a new filename-and-line-number appears.
  208.        t))
  209.       (set-buffer old-buffer))
  210.     (if moving (goto-char (process-mark proc)))))
  211.  
  212. (defun psd-sentinel (proc msg)
  213.   (cond ((null (buffer-name (process-buffer proc)))
  214.      ;; buffer killed
  215.      ;; Stop displaying an arrow in a source file.
  216.      (setq overlay-arrow-position nil)
  217.      (set-process-buffer proc nil))
  218.     ((memq (process-status proc) '(signal exit))
  219.      ;; Stop displaying an arrow in a source file.
  220.      (setq overlay-arrow-position nil)
  221.      ;; Fix the mode line.
  222.      (setq mode-line-process
  223.            (concat ": "
  224.                (symbol-name (process-status proc))))
  225.      (let* ((obuf (current-buffer)))
  226.        ;; save-excursion isn't the right thing if
  227.        ;;  process-buffer is current-buffer
  228.        (unwind-protect
  229.            (progn
  230.          ;; Write something in *compilation* and hack its mode line,
  231.          (set-buffer (process-buffer proc))
  232.          ;; Force mode line redisplay soon
  233.          (set-buffer-modified-p (buffer-modified-p))
  234.          (if (eobp)
  235.              (insert ?\n mode-name " " msg)
  236.            (save-excursion
  237.              (goto-char (point-max))
  238.              (insert ?\n mode-name " " msg)))
  239.          ;; If buffer and mode line will show that the process
  240.          ;; is dead, we can delete it now.  Otherwise it
  241.          ;; will stay around until M-x list-processes.
  242.          (delete-process proc))
  243.          ;; Restore old buffer, but don't restore old point
  244.          ;; if obuf is the psd buffer.
  245.          (set-buffer obuf))))))
  246.  
  247. (defun psd-display-frame (&optional nodisplay noauto)
  248.   "Find, obey and delete the last filename-and-line marker from PSD.
  249. The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n.
  250. Obeying it means displaying in another window the specified file and line."
  251.   (interactive)
  252.   (and psd-last-frame (not nodisplay)
  253.        (or (not psd-last-frame-displayed-p) (not noauto))
  254.        (progn (psd-display-line (car psd-last-frame) (cdr psd-last-frame))
  255.           (setq psd-last-frame-displayed-p t))))
  256.  
  257. ;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
  258. ;; and that its line LINE is visible.
  259. ;; Put the overlay-arrow on the line LINE in that buffer.
  260.  
  261. (defun psd-display-line (true-file line)
  262.   (let* ((buffer (find-file-noselect true-file))
  263.      (window (display-buffer buffer t))
  264.      (pos))
  265.     (save-excursion
  266.       (set-buffer buffer)
  267.       (save-restriction
  268.     (widen)
  269.     (goto-line line)
  270.     (setq pos (point))
  271.     (setq overlay-arrow-string "=>")
  272.     (or overlay-arrow-position
  273.         (setq overlay-arrow-position (make-marker)))
  274.     (set-marker overlay-arrow-position (point) (current-buffer)))
  275.       (cond ((or (< pos (point-min)) (> pos (point-max)))
  276.          (widen)
  277.          (goto-char pos))))
  278.     (set-window-point window overlay-arrow-position)))
  279.  
  280. ;;
  281. ;; Instrument a Scheme file and load it into Scheme.
  282. ;;
  283.  
  284. (defun psd-debug-file (file-name)
  285.   "Instrument a Scheme file and load it into the Scheme interpreter."
  286.   (interactive (comint-get-source "Debug Scheme file: "
  287.                   scheme-prev-l/c-dir/file
  288.                   scheme-source-modes t)) ; T because LOAD 
  289.                     ; needs an exact name
  290.   (comint-check-source file-name)    ; Check to see if buffer needs saved.
  291.   (setq scheme-prev-l/c-dir/file (cons (file-name-directory    file-name)
  292.                        (file-name-nondirectory file-name)))
  293.   (send-string "scheme" (concat "(instrument-file \""
  294.                 file-name
  295.                 "\" \""
  296.                 *psd-tmp-target-file*
  297.                 "\"\)\n"))
  298.   (send-string "scheme" (concat "(load \""
  299.                 *psd-tmp-target-file*
  300.                 "\"\)\n"))
  301.   (switch-to-scheme t))
  302.  
  303. ;;;
  304. ;;; Write a Scheme definition into a file, instrument it with psd and
  305. ;;; load it into the interpreter. Use #line directives for informing
  306. ;;; psd where the definition originally came from.
  307. ;;; 
  308.  
  309. (defun psd-send-definition ()
  310.   "Instrument a definition and load it into Scheme."
  311.   (interactive)
  312.   (save-excursion
  313.     (beginning-of-defun)
  314.     (let ((beginning (point))
  315.       (line (1+ (count-lines 1 (point))))
  316.       (char (1+ (current-column)))
  317.       (file (buffer-file-name)))
  318.       (end-of-defun)
  319.       (copy-region-as-kill beginning (point))
  320.       (find-file *psd-tmp-source-file*)
  321.       (erase-buffer)
  322.       (insert "#line \"" file "\" "
  323.           (int-to-string line) " "
  324.           (int-to-string char) " #\n")
  325.       (yank)
  326.       (save-buffer 0)))
  327.   (psd-debug-file *psd-tmp-source-file*))
  328.  
  329. (defun psd-send-definition-and-go ()
  330.   "Instrument a definition and load it into Scheme. Switches to the
  331. Scheme buffer."
  332.  (psd-send-definition arg)
  333.  (switch-to-scheme))
  334.  
  335. ;;;
  336. ;;; These are installed into scheme-mode-map in place of the normal commands
  337. ;;;
  338.  
  339. (defun scheme-or-psd-send-definition (&optional arg)
  340.   "Without argument, send a definition to the Scheme process.
  341. With argument, instrument a definition and send it to the Scheme process."
  342.   (interactive "P")
  343.   (if arg
  344.       (psd-send-definition)
  345.     (scheme-send-definition)))
  346.   
  347. (defun scheme-or-psd-send-definition-and-go (&optional arg)
  348.   "Without argument, send a definition to the Scheme process.
  349. With argument, instrument a definition and send it to the Scheme process.
  350. Switches to the Scheme buffer."
  351.   (interactive "P")
  352.   (if arg
  353.       (psd-send-definition-and-go)
  354.     (scheme-send-definition-and-go)))
  355.   
  356.  
  357. ;;;
  358. ;;; Set a breakpoint in current line. This command is ment to be used
  359. ;;; in buffers containing Scheme source code.
  360. ;;;
  361.  
  362. (defun psd-set-breakpoint ()
  363.   "Set a breakpoint in current line. This command is ment to be used
  364. in buffers containing Scheme source code."
  365.   (interactive)
  366.   (send-string "scheme" (concat "(psd-set-breakpoint \""
  367.                 (buffer-file-name (current-buffer))
  368.                 "\" "
  369.                 (save-restriction
  370.                   (save-excursion
  371.                     (widen)
  372.                     (beginning-of-line)
  373.                     (1+ (count-lines 1 (point)))))
  374.                 ")\n")))
  375.  
  376. ;;;
  377. ;;; Reset the psd runtime clearing all breakpoints and resetting the
  378. ;;; runtime system into the initial state.
  379. ;;;
  380.  
  381. (defun psd-reset ()
  382.   "Reset the psd runtime clearing all breakpoints and resetting the
  383. runtime system into the initial state."
  384.   (interactive)
  385.   (send-string "scheme" "(psd-reset)\n"))
  386.  
  387.  
  388.